home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / basic / glib19.zip / GLIBDEMO.BAS < prev    next >
Encoding:
BASIC Source File  |  1991-06-27  |  32.2 KB  |  1,231 lines
  1. '
  2. ' GLIBDEMO version 3.5
  3. ' (C) Copyright 1987-1990, 1991
  4. '
  5. ' Demo of some of the newer, more useful or more interesting
  6. ' routines from GLIB version 1.9 for QuickBASIC 4.5
  7. '
  8. ' Written by Gizmo Mike
  9. '
  10. ' NOTE: This should have started from the batch file for proper
  11. '       switch settings.
  12. ' QB glibdemo /l glib19 /cmd <scrfile> <3 or 4 fake switches>
  13.  
  14. DECLARE FUNCTION AttrMake% (fg%, bg%)
  15. DECLARE FUNCTION ArgCnt%
  16. DECLARE FUNCTION ArgVar$ (x%)
  17. DECLARE FUNCTION MenuChoice% (menu$(), Trow%, LCol%, NAttr%, Hattr%, title$, Mark%(), XtdChc%)
  18. DECLARE FUNCTION DIR% (mask$, BYVAL FilArryPtr)
  19. DECLARE FUNCTION CPUInfo% (model%, submodel%, BiosRev%, cpu%, ndp%)
  20. DECLARE FUNCTION DayOfYr%
  21. DECLARE FUNCTION DialogBox$ (msg$, prompt$, ok$)
  22. DECLARE FUNCTION ExtMemFree%
  23. DECLARE FUNCTION ExtMemInst%
  24. DECLARE FUNCTION FUnique% (Fil$, attr%, handle%)
  25. DECLARE FUNCTION FClose% (handle%)
  26. DECLARE FUNCTION FCount% (mask$)
  27. DECLARE FUNCTION FReadArray% (SEG arry%, fhandle%, bytes%)
  28. DECLARE FUNCTION FExists% (Fil$)
  29. DECLARE FUNCTION FuncResp% ()
  30. DECLARE FUNCTION GetCh$ (ok$)
  31. DECLARE FUNCTION GetDrv% ()
  32. DECLARE FUNCTION GetCmdStr$
  33. DECLARE FUNCTION GetCmdTLen%
  34. DECLARE FUNCTION GetStack%
  35. DECLARE FUNCTION KeyReady%
  36. DECLARE FUNCTION LCount% (fhandle%, buffer$)
  37. DECLARE FUNCTION MenuCtrl% ()
  38. DECLARE FUNCTION MHz&
  39. DECLARE FUNCTION ParseFileSpec% (raw$, SEG FInfo AS ANY)
  40. DECLARE FUNCTION PrgName$
  41. DECLARE FUNCTION PtrStat% (x%)
  42. DECLARE FUNCTION SysTicks&
  43. DECLARE FUNCTION SubDirGet$
  44. DECLARE FUNCTION VidType% ()
  45. DECLARE FUNCTION VLabelGet$ (drv%)
  46. DECLARE FUNCTION VerifyGet% ()
  47.  
  48. DECLARE SUB SaveScrn (SEG arry%)
  49. DECLARE SUB RestScrn (SEG arry%)
  50. DECLARE SUB DirF (mask$, SEG FilArryPtr AS ANY)
  51. DECLARE SUB PrintStatL (SEG MsgArray AS ANY, action%, attr%)
  52.  
  53. CLEAR
  54. DEFINT A-Z
  55. OPTION BASE 1
  56.  
  57.     TYPE structf
  58.         drv AS STRING * 2
  59.         Path AS STRING * 64
  60.         Fil AS STRING * 8
  61.         Ext AS STRING * 3
  62.     END TYPE
  63.  
  64.     DIM FInfo AS structf                ' ParseFIle structure defined
  65.  
  66.  
  67.  
  68.     CLS
  69.     crt = VidType                       ' get type of display
  70.  
  71.     IF crt MOD 2 = 0 THEN               ' set colors based on CRT Type
  72.         fg = 7                          ' EGA mono, Mono, or VGA mono
  73.         fgh = 15                        ' use bland colors
  74.         fgw = 0
  75.         bgw = 7
  76.         NAttr = 112
  77.         Rattr = 7
  78.         cmode = 0
  79.     ELSE
  80.         fg = 3                     ' CGA, EGA or VGA
  81.         fgh = 14                   ' use less bland colors
  82.         fgw = 14
  83.         bgw = 4
  84.         NAttr = 78
  85.         Rattr = 14
  86.         cmode = 1
  87.     END IF
  88.     COLOR fg, 0
  89.  
  90.     TYPE struct                         ' type structure for DirF
  91.         s AS STRING * 12
  92.     END TYPE
  93.  
  94.     TYPE structa
  95.         ls AS STRING * 80
  96.     END TYPE
  97.  
  98.     REDIM menu$(28)                     ' string array of demo choices
  99.     REDIM Mark(28)                      ' allow marking of up to 5
  100.  
  101.     REDIM TSqMsg$(4)                    ' TimeSquare msgs
  102.     TSqMsg$(1) = "Press any key to continue"
  103.     TSqMsg$(2) = "GLIB: The standard in QB Libraries"
  104.     TSqMsg$(3) = "This is a demo of TimeSquare"
  105.     TSqMsg$(2) = "GLIB: So much Power, so few $$$"
  106.  
  107.     'set up status line messages
  108.     REDIM SLine(2) AS structa
  109.     SLine(1).ls = "               Navigate with Cursor keys.   Select with [Enter]  "
  110.     SLine(2).ls = "    Mark up to 5 selections with [TAB] or [SpaceBar].    [Esc] Quits Demo"
  111.  
  112.  
  113.  
  114.     REDIM ScrText((7 * 2000) + 1)       ' up to 5 info screens
  115.  
  116.     REDIM ScrnArry(12001)               ' enough for 6 screens
  117.  
  118.     REDIM temp(10)                      ' for printing GLIB returns in a loop
  119.  
  120.     NumArgs = ArgCnt                    ' call Argument Count function
  121.  
  122.     IF (NumArgs = 0) OR (FExists(Arg$(1)) = 0) THEN
  123.         ScrFil$ = "ScrLib19.DAT"
  124.         IF FExists(ScrFil$) = 0 THEN
  125.             GOSUB HowToRunDemo
  126.             SYSTEM
  127.         END IF
  128.     ELSE
  129.         ScrFil$ = ArgVar$(5)
  130.         ScrNum = 0                      ' screen to load
  131.     END IF
  132.  
  133.     ' the demo selections
  134.     DATA Other InfoSoft Items, Boxes, Chirp, ArgCnt/ArgVar/GetCmdTail, Date / DFRMAT, DIR
  135.     DATA DrvSpace, DayOfYr, DialogBox, FExists/FileDNE, FlexMenu, FUnique
  136.     DATA GetCH/PGetCh, LCount, MenuCtrl/FuncResp, PrgName/Parse, Printer Routines (4)
  137.     DATA Painter, QPrint, Equip Info Routines, "Scrolling (U/D, L/R)"
  138.     DATA TFrmat/Systime, Save/Rest Scrn, Windows, VidON / VidOFF
  139.     DATA Read / Write Array, Read / Write String, QUIT Demo (or [Esc])
  140.  
  141.     FOR x = 1 TO 28                     ' build the main menu
  142.         READ menu$(x)
  143.     NEXT x
  144.  
  145.     FOR x = 1 TO 3
  146.         ScrNum = x                      ' set screen to load
  147.         ScrPOS = ((x - 1) * 2000) + 1   ' array position to load to
  148.         GOSUB LoadScrn
  149.     NEXT x
  150.  
  151.     FOR x = 1 TO 3
  152.         ScrOffs = ((x - 1) * 2000) + 1  ' set offset pointer to array
  153.         CALL RestScrn(ScrText(ScrOffs)) ' display screen
  154.         x$ = INPUT$(1)                  ' eat key press
  155.     NEXT x
  156.  
  157.     title$ = " GLIB Demo "              ' FlexMenu title
  158.     First = LBOUND(menu$)               ' first possible selection
  159.     Last = UBOUND(menu$)                ' last (in case somebody messes with it)
  160.  
  161.  
  162.     DO
  163.         CLS
  164.         MarkedItem = 0                  ' reset flags
  165.         ArrayPOS = 0
  166.         XtdChc = 5                      ' how many marks to allow
  167.         REDIM Mark(Last)                ' erase old marks
  168.  
  169.         CALL PrintStatL(SLine(1), 0, 112)
  170.  
  171.         item = MenuChoice%(menu$(), -1, -1, NAttr%, Rattr%, title$, Mark%(), XtdChc%)
  172.  
  173.         IF XtdChc <> 27 THEN
  174.             FOR i = First TO Last       ' check for marked items
  175.                 IF Mark(i) THEN
  176.  
  177.                     item = i
  178.                     MarkedItem = 1
  179.                     IF (item < Last + 1) THEN
  180.                         GOSUB ExecItem
  181.                     END IF
  182.  
  183.                 END IF
  184.             NEXT i
  185.  
  186.             IF MarkedItem = 0 THEN
  187.                 GOSUB ExecItem
  188.             END IF
  189.         END IF
  190.  
  191.     LOOP UNTIL (XtdChc = 27) OR (item = Last + 1)
  192.  
  193.     ' closing sequence
  194.     CLS
  195.  
  196.     ScrNum = 1                     ' set screen to load
  197.     ScrPOS = 1
  198.     GOSUB LoadScrn
  199.     CALL RestScrn(ScrText(1))
  200.  
  201.     msg$(1) = " Place your GLIB order now!  "          ' change final msgs
  202.     msg$(3) = " Place your GLIB order now!  "
  203.     LOCATE 24, 3
  204.     PRINT SPACE$(60);
  205.  
  206.     CALL TimeSquare(msg$(), 24, 23, NAttr, 0)
  207.  
  208.     LOCATE 24, 3
  209.     PRINT SPACE$(60);
  210.     LOCATE 23, 1
  211.  
  212. SYSTEM
  213.  
  214. ExecItem:
  215.     IF item > 20 THEN item = item + 1
  216.  
  217.     CLS
  218.  
  219.     DoFade = 0
  220.  
  221.     ScrNum = item + 3                   ' adjust for logo etc
  222.     ScrPOS = 1                          ' adjust for OTHER INFO
  223.     GOSUB LoadScrn
  224.  
  225.     'IF item <> 23 THEN
  226.     CALL RestScrn(ScrText(ScrPOS))
  227.     'END IF
  228.  
  229.     SELECT CASE item
  230.         CASE 0, 1, 11
  231.  
  232.         CASE 2
  233.             x$ = INPUT$(1)
  234.             GOSUB BoxDemo
  235.  
  236.         CASE 3
  237.             GOSUB ChirpDemo
  238.  
  239.         CASE 4
  240.             GOSUB CmdLDemo
  241.  
  242.         CASE 5
  243.             GOSUB DateStuff
  244.  
  245.         CASE 6
  246.             x$ = INPUT$(1)
  247.             GOSUB DirDemo
  248.  
  249.         CASE 7
  250.             GOSUB DrvSpaceDemo
  251.  
  252.         CASE 8
  253.             GOSUB DayYrDemo
  254.  
  255.         CASE 9
  256.             x$ = INPUT$(1)
  257.             GOSUB DialogBoxDemo
  258.  
  259.         CASE 10
  260.             GOSUB ExistDemo
  261.  
  262.         CASE 12
  263.             GOSUB UniqDemo
  264.  
  265.         CASE 13
  266.             GOSUB GetChDemo
  267.     
  268.         CASE 14
  269.             GOSUB LCountDemo
  270.  
  271.         CASE 15
  272.             GOSUB MenuCtrlDemo
  273.  
  274.         CASE 16
  275.             GOSUB PrgNameDemo
  276.  
  277.         CASE 17
  278.             GOSUB PtrDemo
  279.  
  280.         CASE 18
  281.             x$ = INPUT$(1)
  282.             GOSUB PaintDemo
  283.  
  284.         CASE 19
  285.             x$ = INPUT$(1)
  286.             GOSUB QPrintDemo
  287.  
  288.         CASE 20
  289.             speed = MHz& / 100       ' do test while reading screen
  290.             x$ = INPUT$(1)
  291.             ScrNum = ScrNum + 1     ' adjust for logo etc
  292.             ScrPOS = 2              ' adjust for OTHER INFO
  293.             GOSUB LoadScrn
  294.  
  295.             CALL RestScrn(ScrText(ScrPOS))
  296.  
  297.             GOSUB SysInfoDemo
  298.  
  299.  
  300.         CASE 22
  301.             x$ = INPUT$(1)
  302.             GOSUB ScrlDemo
  303.  
  304.         CASE 23
  305.             GOSUB TimeDemo
  306.  
  307.         CASE 24
  308.             x$ = INPUT$(1)
  309.             ScrNum = ScrNum + 1          ' adjust for logo etc
  310.             ScrPOS = 2                   ' adjust for OTHER INFO
  311.             GOSUB LoadScrn
  312.  
  313.             CALL RestScrn(ScrText(ScrPOS))
  314.             x$ = INPUT$(1)
  315.             GOSUB SrWdwsDemo
  316.  
  317.  
  318.         CASE 25
  319.             x$ = INPUT$(1)
  320.             GOSUB SrWdwsDemo
  321.  
  322.  
  323.         CASE 26
  324.             x$ = INPUT$(1)
  325.             GOSUB VidDemo
  326.  
  327.         CASE 27, 28
  328.  
  329.         CASE ELSE
  330.                 
  331.     END SELECT
  332.  
  333.  
  334.     GOSUB ContPrompt
  335.     COLOR fg, 0
  336.  
  337. RETURN
  338.  
  339.  
  340.  
  341. '************* demo code ****************
  342. BoxDemo:
  343.     CLS
  344.     CALL Boxes(1, 1, 6, 25, 1, 7)
  345.     CALL MilliDelay(500)                ' pause long enough to appreciate
  346.     CALL Boxes(10, 1, 20, 45, 2, 78)
  347.     CALL MilliDelay(500)                ' otherwise all 7 pop up too fast
  348.     CALL Boxes(1, 41, 16, 80, 3, 3)
  349.     CALL MilliDelay(500)
  350.     CALL Boxes(16, 31, 25, 75, 7, 14)
  351.     CALL MilliDelay(500)
  352.     CALL Boxes(5, 15, 23, 35, 6, 3)
  353.     CALL MilliDelay(500)
  354.     CALL Boxes(5, 55, 13, 79, 5, 2)
  355.     CALL Delay18(2)
  356.     CALL Boxes(15, 5, 18, 65, 6, 2)
  357.     COLOR fgh, 0
  358.     LOCATE 17, 7
  359.     PRINT "Boxes can be placed anywhere and support 9 frame styles"
  360.     DoFade = 1
  361. RETURN
  362.  
  363.  
  364. ChirpDemo:
  365.     FOR x = 1 TO 5
  366.         LOCATE 13 + x, 5
  367.         IF x MOD 2 THEN
  368.             CALL Chirp(0)
  369.             PRINT "Ascending"
  370.         ELSE
  371.             CALL Chirp(1)
  372.             PRINT "Descending"
  373.         END IF
  374.         CALL Delay18(12)                ' about 3/4 sec
  375.     NEXT x
  376. RETURN
  377.  
  378.  
  379. CmdLDemo:
  380.     x$ = INPUT$(1)                      ' eat a key
  381.  
  382.     TLen = GetCmdTLen                   ' get command tail len
  383.     IF TLen > 0 THEN
  384.         Tail$ = GetCmdStr$              ' get command tail from PSP
  385.     END IF
  386.  
  387.                     ' clear lower portion of screen
  388.     CALL Windows(9, 2, 23, 79, 0, 1, 0, 0, "")
  389.     LOCATE 9, 5
  390.     PRINT "Command tail direct from PSP is:"
  391.     LOCATE 10, 5
  392.  
  393.     IF TLen > 0 THEN
  394.         PRINT Tail$
  395.         LOCATE 12, 5
  396.         PRINT "Command line passed to QB:"
  397.         PRINT TAB(5); CLine$
  398.     ELSEIF TLen = -3 THEN
  399.         PRINT "Available under DOS 3.0+"
  400.     ELSE
  401.         PRINT "None"
  402.     END IF
  403.  
  404.     IF NumArgs THEN
  405.         FOR x = 1 TO NumArgs
  406.             LOCATE 12 + x, 10
  407.             PRINT "Argument number "; x; ": "; ArgVar$(x)
  408.         NEXT x
  409.     ELSE
  410.         LOCATE 11, 10
  411.         PRINT "No command line entered"
  412.     END IF
  413.  
  414. RETURN
  415.  
  416.  
  417. DateStuff:
  418.     CALL date(mo, day, yr, dow)         ' get date variables
  419.     CALL dfrmat(mo, day, yr, nudat$)    ' format to string
  420.     COLOR fgh, 0
  421.     LOCATE 14, 28
  422.     PRINT DATE$
  423.     LOCATE 15, 33
  424.     PRINT nudat$
  425.     LOCATE 19, 55
  426.     PRINT mo; day; yr; dow              ' show DATE return
  427. RETURN
  428.  
  429. DirDemo:
  430.     mask$ = "*.bas"                     ' look for these files
  431.     cnt = FCount(mask$)
  432.  
  433.     IF cnt < 3 THEN
  434.         mask$ = "*.*"                   ' not enough files to be impressive
  435.         cnt = FCount(mask$)             ' try *.*
  436.     END IF
  437.  
  438.     REDIM FileList(cnt) AS struct       ' set up filelist as an array of
  439.                                         ' cnt size of TYPE struct which
  440.                                         ' contains only a Fixed Len Str
  441.                                         ' of 12 chars long.
  442.                                         ' - re structure 'STRUCT' as a string
  443.                                         ' 11 or 13 chars long and see what
  444.                                         ' happens.  The result is from the
  445.                                         ' unique way QB structures Fixed Length
  446.                                         ' Strings.
  447.  
  448.     CALL DirF(mask$, FileList(1))       ' fill the array with the found files
  449.     CLS                                 ' print them.
  450.  
  451.     COLOR fgh, 0
  452.     LOCATE 2, 25
  453.     PRINT cnt;
  454.     COLOR fg, bg
  455.     PRINT " Files Found in mask "; : COLOR fgh, 0: PRINT mask$
  456.     IF cnt > 51 THEN
  457.         COLOR 7, 0
  458.         PRINT TAB(20); "(Only the first 51 will be displayed.)"
  459.         cnt = 51
  460.     END IF
  461.  
  462.     y = 1
  463.     z = 1
  464.     col = 10
  465.     COLOR fg, 0
  466.  
  467.     rowcnt = (cnt \ 3)                       ' even number rows in display
  468.  
  469.  
  470.     FOR x = 1 TO rowcnt                 ' print them in reasonably orderly
  471.                                         ' fashion
  472.         FOR y = 1 TO 3
  473.             LOCATE 5 + x, 10 + ((y - 1) * 25)
  474.             PRINT z; FileList(z).s
  475.             z = z + 1
  476.         NEXT y
  477.  
  478.     NEXT x
  479.  
  480.     y = 1
  481.     LOCATE 5 + x, 10 + ((y - 1) * 25)
  482.  
  483.  
  484.     FOR q = z TO cnt
  485.         PRINT q; FileList(q).s; TAB(10 + (y * 25));
  486.     NEXT q
  487.             
  488. RETURN
  489.  
  490.  
  491. DrvSpaceDemo:
  492.     A = 0                               ' poll default drive
  493.     CALL drvspace(A, b, c, d)
  494.                                         ' interpet returns
  495.     TotSpace& = CLNG(A%) * CLNG(c%) * CLNG(d%)
  496.     FreeSpc& = CLNG(A%) * CLNG(c%) * CLNG(b%)
  497.  
  498.     COLOR fg                            ' display what we know
  499.     LOCATE 12, 28
  500.     PRINT TotSpace&; "bytes"
  501.     LOCATE 14, 28
  502.     PRINT FreeSpc&; "bytes"
  503. RETURN
  504.  
  505.  
  506. DayYrDemo:
  507.     LOCATE 10, 42
  508.     COLOR fgh, 0
  509.     PRINT DayOfYr                        ' no need to assign it
  510. RETURN
  511.  
  512.  
  513. DialogBoxDemo:
  514.     msg$ = "Do you want to change defaults?"
  515.     prompt$ = "Yes or No?"
  516.     ok$ = "YN"
  517.     ret$ = " "
  518.  
  519.     CALL SaveScrn(ScrnArry(1))
  520.     ret$ = DialogBox(msg$, prompt$, ok$)
  521.  
  522.     CALL RestScrn(ScrnArry(1))
  523.     CALL DBoxSetUDef(3, 3, 2, 78)
  524.  
  525.     IF ret$ = "Y" THEN
  526.         msg$ = "Good, because I wanted to show this"
  527.     ELSE
  528.         msg$ = "Too bad, because I did want to..."
  529.     END IF
  530.     prompt$ = "Press any key"
  531.     ok$ = ""
  532.     ret$ = " "
  533.  
  534.     ret$ = DialogBox(msg$, prompt$, ok$)
  535.     CALL DBoxClrUDef
  536.     CALL RestScrn(ScrnArry(1))
  537. RETURN
  538.  
  539.  
  540. ExistDemo:
  541.     LOCATE 20, 10
  542.     Fil$ = "GLIBDEMO.BAS"
  543.     PRINT Fil$;
  544.     IF FExists(Fil$) THEN               ' test it
  545.         PRINT " exists!"                ' print findings
  546.     ELSE
  547.         PRINT " is missing."
  548.     END IF
  549.  
  550.     LOCATE 21, 10
  551.     Fil$ = "FOOBAR.EXE"
  552.     PRINT Fil$;
  553.     IF FExists(Fil$) THEN
  554.         PRINT " exists!"
  555.     ELSE
  556.         PRINT " is missing."
  557.     END IF
  558. RETURN
  559.  
  560.  
  561. UniqDemo:
  562.     Fil$ = SPACE$(64)                   ' storage for returns
  563.  
  564.     CDir$ = SubDirGet$
  565.     LSET Fil$ = "\" + LTRIM$(RTRIM$(CDir$)) + "\"  ' store it in fil$
  566.  
  567.     errc = FUnique(Fil$, 0, uh)         ' 0 = normal attribute,
  568.                                         '   make and open unique filename
  569.     errc = FClose(uh)                   ' close the file
  570.     LOCATE 20, 15
  571.  
  572.     PRINT "Were I to need a scratch file, I could use:"; TAB(10);
  573.  
  574.     COLOR fgh, 0
  575.     Fil$ = LTRIM$(RTRIM$(Fil$))
  576.     PRINT Fil$                          ' print significant part of temp file
  577.     KILL Fil$
  578. RETURN
  579.  
  580.  
  581. GetChDemo:
  582.     ky$ = " "
  583.     LOCATE 24, 20
  584.     PRINT "Understand the idea here (Y/N)?        ";
  585.     ret$ = GetCh("YN")                  ' only Y or N will be acted upon
  586.     LOCATE 24, 10
  587.     PRINT SPACE$(40);                   ' erase prompt
  588. RETURN
  589.  
  590.  
  591. LCountDemo:
  592.     Fil$ = "GLIB17.DOC"                 ' target file
  593.     LOCATE 21, 5
  594.     PRINT Fil$;
  595.  
  596.     IF FExists(Fil$) THEN               ' can we access it?
  597.         ff = FREEFILE
  598.         OPEN Fil$ FOR INPUT AS #ff      ' open it
  599.         ffh = FILEATTR(ff, 2)           ' convert to handle
  600.         t! = TIMER                      ' start timer
  601.  
  602.         ' check out the self destructing buffer used here
  603.         NumLines = LCount(ffh, SPACE$(4096))
  604.  
  605.         ' a second pass on this will show a LOT faster time
  606.         PRINT " has"; NumLines; "lines and I took "; TIMER - t!; " secs to count them!"
  607.         CLOSE #ff                       ' close the file
  608.     ELSE
  609.         PRINT " does not exist!"
  610.     END IF
  611.  
  612.     Fil$ = "GLIBDEMO.BAS"
  613.     LOCATE 22, 5
  614.     PRINT Fil$;
  615.  
  616.     IF FExists(Fil$) THEN
  617.         ff = FREEFILE
  618.         OPEN Fil$ FOR INPUT AS #ff
  619.         ffh = FILEATTR(ff, 2)
  620.         t! = TIMER
  621.  
  622.         NumLines = LCount(ffh, SPACE$(4096))
  623.         PRINT " has"; NumLines; "lines and I took "; TIMER - t!; " to count them!"
  624.         CLOSE #ff
  625.     ELSE
  626.         PRINT " does not exist!"
  627.     END IF
  628.  
  629.  
  630. RETURN
  631.  
  632.  
  633. MenuCtrlDemo:
  634.     x$ = INPUT$(1)
  635.     done = 0
  636.  
  637.     LOCATE 23, 1
  638.     PRINT SPACE$(70);
  639.  
  640.     CALL SaveScrn(ScrnArry(1))
  641.     msg$ = "Do demo for MenuCtrl or FuncResp?"
  642.     prompt$ = "Select 'M' or 'F'"
  643.     ret$ = " "
  644.     ret$ = DialogBox(msg$, prompt$, "MF")
  645.     CALL RestScrn(ScrnArry(1))
  646.  
  647.     LOCATE 22, 25
  648.     IF ret$ = "M" THEN
  649.         PRINT "Press [Esc] to quit"
  650.     ELSE
  651.         PRINT "Press [Ctrl-F10] to quit"
  652.     END IF
  653.  
  654.     DO
  655.         LOCATE 23, 30
  656.         IF ret$ = "M" THEN
  657.             code = MenuCtrl                 ' get a F or nunber key
  658.             IF code <> 15 THEN
  659.                 PRINT USING "You pressed [F-##] or the number ##"; code; code
  660.             ELSE
  661.                 done = 1
  662.             END IF
  663.         ELSE
  664.             code = FuncResp                 ' get a F key press
  665.             SELECT CASE code
  666.                 CASE 1 TO 10
  667.                     PRINT USING "You pressed [F-##] "; code
  668.                 CASE 11 TO 20
  669.                     PRINT USING "You pressed Shift+[F-##] "; code - 10
  670.                 CASE 21 TO 30
  671.                     PRINT USING "You pressed Alt+[F-##] "; code - 20
  672.                 CASE 31 TO 40
  673.                     PRINT USING "You pressed Ctrl+[F-##] "; code - 30
  674.             END SELECT
  675.  
  676.             IF code = 40 THEN done = 1
  677.         END IF
  678.  
  679.     LOOP UNTIL done
  680. RETURN
  681.  
  682.  
  683. PrgNameDemo:
  684.     Prg$ = PrgName$                     ' get name of program running
  685.  
  686.     errc = ParseFileSpec(Prg$, FInfo)
  687.  
  688.     LOCATE 18, 20
  689.     PRINT "Name of loaded program: "; Prg$
  690.  
  691.     LOCATE 19, 20
  692.     PRINT "Parsed that is:"
  693.     PRINT TAB(25); "    Drive: "; FInfo.drv
  694.     PRINT TAB(25); "     Path: "; RTRIM$(FInfo.Path)
  695.     PRINT TAB(25); "     File: "; FInfo.Fil
  696.     PRINT TAB(25); "Extension: "; FInfo.Ext
  697.  
  698. RETURN
  699.  
  700.  
  701. PaintDemo:
  702.     CLS
  703.     FOR x = 1 TO 405                    ' print a test pattern
  704.         PRINT x;
  705.     NEXT
  706.  
  707.     CALL SaveScrn(ScrnArry(1))          ' save the test pattern
  708.     CALL RestScrn(ScrnArry(1))          ' restore it
  709.  
  710.     FOR x = 1 TO 35 STEP 5              ' the rainbow
  711.         CALL painter(1, 1, 12, 40, x)
  712.         IF crt <> 2 THEN                ' if CGA crt type then
  713.             CALL Delay18(3)             '  slow down demo for
  714.         END IF                          '  appreciation
  715.  
  716.         CALL painter(12, 1, 25, 40, x + 1)
  717.         IF crt <> 2 THEN
  718.             CALL Delay18(3)
  719.         END IF
  720.  
  721.  
  722.         CALL painter(1, 41, 12, 80, x + 2)
  723.         IF crt <> 2 THEN
  724.             CALL Delay18(3)
  725.         END IF
  726.  
  727.         CALL painter(12, 41, 25, 80, x + 3)
  728.         IF crt <> 2 THEN
  729.             CALL Delay18(3)
  730.         END IF
  731.  
  732.         CALL RestScrn(ScrnArry(1))      ' restore screen
  733.     NEXT x
  734.  
  735.     CALL RestScrn(ScrText(ScrPOS))      ' restore Syntax screen
  736.     CALL painter(9, 1, 25, 80, 0)       ' make top part COLOR 0,0
  737.  
  738.     LOCATE 9, 5
  739.     PRINT "Painter can also be used to hide text as we have on this screen."
  740.     PRINT TAB(5); "Press any key to unhide it..."
  741.     
  742.     DO
  743.     LOOP UNTIL KeyReady
  744.  
  745.     CALL painter(9, 1, 25, 80, 7)       ' convert to COLOR 7,0
  746.     DoFade = 1
  747.  
  748. RETURN
  749.       
  750. PtrDemo:
  751.     x$ = INPUT$(1)
  752.     msg$ = "Perform PrtScrn demo ?"
  753.     prompt$ = "Yes or No"
  754.     ok$ = "YN"
  755.     CALL SaveScrn(ScrnArry(1))
  756.     ret$ = DialogBox$(msg$, prompt$, ok$)
  757.     CALL RestScrn(ScrnArry(1))
  758.  
  759.     IF ret$ = "Y" THEN
  760.         CALL PrtScrn                    ' darn simple
  761.     END IF
  762.  
  763.     LOCATE 22, 5
  764.     PRINT "Initialize LPT1: ";
  765.     CALL PtrInit(1)                     ' legal printers are 1 to 4
  766.     
  767.     LOCATE 22, 5
  768.     COLOR fg, 0
  769.     PRINT "Checking status (wait a sec first): "
  770.     CALL Delay(2)                       ' wait for low tech item
  771.     stat = PtrStat(1)                   ' get status for prtr one
  772.  
  773.     LOCATE 23, 5
  774.     PRINT "Printer is ";
  775.     COLOR fgh, 0
  776.  
  777.     IF stat THEN
  778.         PRINT "ready!"
  779.     ELSE
  780.         PRINT "not responding!"
  781.     END IF
  782. RETURN
  783.  
  784. QPrintDemo:
  785.     CLS
  786.     pstart! = TIMER                     ' start QB QPRINT timer
  787.  
  788.     FOR z = 1 TO 10
  789.         FOR x = 1 TO 24                 ' fill screen with PRINT
  790.             PRINT STRING$(80, CHR$(47 + z))
  791.         NEXT x
  792.     NEXT z
  793.     pend! = TIMER                       ' halt timer
  794.  
  795.     CLS : BEEP                          ' let 'em know QPrint is on the way
  796.  
  797.     qstart! = TIMER                     ' start QPRINT timer
  798.     FOR z = 1 TO 10                     ' fill screen 10 times
  799.         FOR x = 1 TO 24
  800.             CALL QPrint(STRING$(80, CHR$(47 + z)), x, 1, fg%)
  801.         NEXT x
  802.     NEXT z
  803.     qend! = TIMER                       ' halt QPrint timer
  804.  
  805.     pelaps! = pend! - pstart!           ' calculate elapsed times
  806.     qelaps! = qend! - qstart!
  807.  
  808.     CLS : LOCATE 10, 1                  ' show results
  809.     PRINT "Elapsed time for PRINT "; pelaps!
  810.     PRINT "Elapsed time for QPRINT "; qelaps!
  811.  
  812. RETURN
  813.  
  814.  
  815. SysInfoDemo:
  816.     FOR x = 1 TO 5                      ' initialze vars to 0
  817.        temp(x) = 0
  818.     NEXT x
  819.     CALL EqInfo(temp(1), temp(2), temp(3), temp(4), temp(5))
  820.     '            ram,     par,     ser     GameP     Floppies
  821.  
  822.  
  823.     COLOR fgh, 0
  824.  
  825.     LOCATE 5, 25
  826.     PRINT USING "### kb"; temp(1)
  827.  
  828.     FOR x = 2 TO 5                      ' calling with array variables
  829.         LOCATE 5 + x, 25                ' makes printing easier
  830.         PRINT USING "###"; temp(x)
  831.     NEXT x
  832.  
  833.     Label$ = VLabelGet$(0)
  834.  
  835.     drv$ = CHR$(GetDrv) + ":"           ' get drive
  836.     VFLag = VerifyGet                   ' get V Flag
  837.  
  838.     LOCATE 5, 64
  839.     PRINT drv$
  840.  
  841.     LOCATE 6, 64
  842.     IF VFLag THEN
  843.         PRINT " ON"
  844.     ELSE
  845.         PRINT "OFF"
  846.     END IF
  847.  
  848.     LOCATE 8, 64
  849.     IF LEN(Label$) THEN
  850.         PRINT Label$
  851.     ELSE
  852.         PRINT "(none)"
  853.     END IF
  854.  
  855.     FOR x = 1 TO 5                      ' clear out any old returns
  856.         temp(x) = 0
  857.     NEXT x
  858.  
  859.     CALL VidInfo(temp(1), temp(2), temp(3), temp(4), temp(5))
  860.     '             rows,    cols,    mode,    page,   page size
  861.  
  862.     LOCATE 14, 64
  863.     SELECT CASE crt                     ' crt determined at prog start
  864.         CASE 0
  865.             PRINT "MONO"
  866.         CASE 1
  867.             PRINT "HERC/HGC+"
  868.         CASE 1
  869.             PRINT "HERC InColor"
  870.         CASE 3
  871.             PRINT "CGA"
  872.         CASE 4
  873.             PRINT "EGA Mono"
  874.         CASE 5
  875.             PRINT "EGA Color"
  876.         CASE 6
  877.             PRINT "MCGA Mono"
  878.         CASE 7
  879.             PRINT "MCGA Color"
  880.         CASE 8
  881.             PRINT "VGA Mono"
  882.         CASE 9
  883.             PRINT "VGA Color"
  884.         CASE 10
  885.             PRINT "IBM 8514 EGA"
  886.         CASE ELSE
  887.             PRINT "unknown!"
  888.     END SELECT
  889.  
  890.     FOR x = 1 TO 5
  891.         LOCATE 14 + x, 64
  892.         PRINT USING "####"; temp(x)
  893.         temp(x) = 0                     ' clear for next call while printing
  894.     NEXT x
  895.  
  896.     errc = CPUInfo(temp(1), temp(2), temp(3), temp(4), temp(5))
  897.     '               Model,  Sub Mod, BiosRev,   cpu,    ndp
  898.  
  899.     ' only print Extended memory if AT or better
  900.     IF (temp(4) = 286) OR (temp(4) = 386) THEN
  901.         LOCATE 6, 25
  902.         PRINT USING "### Installed_/### Free"; ExtMemInst; ExtMemFree
  903.     END IF
  904.  
  905.     FOR x = 1 TO 3
  906.         LOCATE 13 + x, 25
  907.         IF (errc <> 0) AND (x > 1) THEN  ' if ERRC is set, SubMdl and BRev
  908.             PRINT "n/a"                  ' not supported
  909.         ELSE
  910.             PRINT USING "###"; temp(x)  ' Model is ok even if Errc
  911.         END IF
  912.     NEXT x
  913.  
  914.     LOCATE 18, 25
  915.     IF temp(4) < 80 THEN                ' print CPU type
  916.         PRINT USING "NEC V-##"; temp(4)
  917.     ELSE
  918.         PRINT USING "INTEL 80###"; temp(4)
  919.     END IF
  920.  
  921.     LOCATE 19, 25                       ' print Math coprocessor type
  922.     IF temp(5) THEN
  923.         PRINT USING "80###"; temp(5)
  924.     ELSE
  925.         PRINT "none "
  926.     END IF
  927.  
  928.     LOCATE 21, 25                       ' speed was calculated while waiting
  929.                                         ' for keypress - see main loop
  930.     PRINT USING "##.# MHz"; speed
  931.     x$ = INPUT$(1)
  932. RETURN
  933.  
  934.  
  935. ScrlDemo:
  936.     COLOR fg, 0                        ' QPRINT a test pattern
  937.     FOR x = 1 TO 24
  938.         CALL QPrint(STRING$(80, CHR$(x + 96)), x, 1, 2)
  939.     NEXT x
  940.  
  941.  
  942.     BEEP
  943.     CALL SaveScrn(ScrnArry(1))          ' save the test pattern
  944.     COLOR fgh, 0
  945.  
  946.     FOR x = 1 TO 15                           ' print the text at the
  947.         CALL ScrollUp(5, 20, 19, 59, fg, 1)    '  same line, let SCROLL
  948.         LOCATE 19, 22                         '  move the text up the screen
  949.         PRINT "Scroll Up Line # "; x;
  950.         CALL Delay18(1)
  951.     NEXT x
  952.  
  953.     COLOR fgh, 0
  954.     LOCATE 15, 44: PRINT "Slow now, w/"
  955.     LOCATE 16, 44: PRINT "frame (from Boxes)!"
  956.  
  957.     GOSUB ContPrompt                    ' wait for you to catch up
  958.  
  959.     CALL RestScrn(ScrnArry(1))          ' restore test pattern
  960.  
  961.     CALL Boxes(5, 28, 17, 52, 6, fgh)
  962.  
  963.     COLOR fg, 0
  964.     FOR x = 1 TO 15        ' loop for 15 lines
  965.         CALL ScrollDn(6, 30, 16, 50, fhg, 1)     '   scroll down a line
  966.         LOCATE 6, 31                            '   at top of window,....
  967.  
  968.         IF cmode THEN
  969.             COLOR x, 0
  970.         ELSE
  971.             COLOR 15, 0
  972.         END IF
  973.         PRINT "Scroll Dn Line #"; x;              '   print the message
  974.         CALL MilliDelay(500)                      '   waitasec
  975.     NEXT x
  976.  
  977.     BEEP
  978.  
  979.     CLS
  980.     LOCATE 10, 22
  981.     PRINT "Now, shifting the screen by Scrolling Left and Right."
  982.  
  983.     GOSUB ContPrompt
  984.  
  985.     CALL RestScrn(ScrnArry(1))          ' restore test pattern
  986.     BEEP
  987.  
  988.     FOR y = 1 TO 80
  989.         CALL ScrlLeft(1, 1, 25, 80, -1, 1) ' scroll L/R with delay
  990.         CALL MilliDelay(100)
  991.     NEXT y
  992.     CALL Delay(1)
  993.  
  994.     CALL RestScrn(ScrnArry(1))          ' restore test pattern
  995.  
  996.     BEEP
  997.     FOR x = 1 TO 80                     ' more
  998.         CALL ScrlRight(5, 10, 20, 70, -1, 1)
  999.         CALL MilliDelay(100)
  1000.     NEXT x
  1001.     SOUND 1200, .75
  1002.     LOCATE 15, 25
  1003.     PRINT "Scrolled lines are lost."
  1004.  
  1005.     CALL Delay(1)
  1006.     LOCATE 16, 30
  1007.     PRINT "Forever"
  1008. RETURN
  1009.  
  1010.  
  1011. TimeDemo:
  1012.      CALL TFrmat(atime$, 1)             ' format with
  1013.      CALL TFrmat(btime$, 0)             ' and without am/pm label
  1014.      CALL SysTime(h, m, s, hh)          ' get low level time
  1015.  
  1016.      COLOR fgh, 0
  1017.      LOCATE 15, 31
  1018.      PRINT TIME$                        ' print BASIC version
  1019.      LOCATE 16, 32
  1020.      PRINT btime$                       ' print ours
  1021.      LOCATE 16, 50
  1022.      PRINT atime$                       ' and ours
  1023.  
  1024.      LOCATE 19, 55
  1025.      PRINT h; m; s; hh                  ' and low level time
  1026.      LOCATE 22, 25
  1027.      PRINT SysTicks&
  1028. RETURN
  1029.  
  1030.  
  1031. SrWdwsDemo:
  1032.     wattr2 = AttrMake(7, 1)             ' set up some attributes
  1033.     wattr3 = AttrMake(1, 7)
  1034.     wattr4 = AttrMake(0, 11)
  1035.     wattr5 = AttrMake(3, 0)
  1036.     wattr6 = AttrMake(5, 14)
  1037.  
  1038.     CALL SaveScrn(ScrnArry(1))          ' now we have the screen with text
  1039.                                         ' captured in array
  1040.  
  1041.                                         ' window that Grows and Chirps
  1042.     CALL Windows(2, 2, 15, 55, 1, 1, 1, NAttr%, "Gro & SFX")
  1043.  
  1044.     IF crt <> 2 THEN
  1045.         CALL MilliDelay(250)            ' pause a bit if NOT CGA
  1046.         LOCATE 8, 5
  1047.         COLOR fgw, bgw                  ' so wdws appear individually
  1048.         PRINT "There is a one quarter second delay"
  1049.         LOCATE , 5
  1050.         PRINT "between each window call for effect."
  1051.         LOCATE , 5
  1052.         PRINT "Untethered, they are even faster!"
  1053.     END IF
  1054.  
  1055.     CALL SaveScrn(ScrnArry(2001))       ' captured one with window one on it
  1056.  
  1057.  
  1058.                                         ' do a window, save the display, then
  1059.                                         ' pause for fast CRTs
  1060.     CALL Windows(12, 5, 23, 30, 0, 0, 2, wattr2%, "No Gro, No SFX")
  1061.     CALL SaveScrn(ScrnArry(4001))
  1062.     IF crt <> 2 THEN
  1063.         CALL MilliDelay(250)
  1064.     END IF
  1065.  
  1066.  
  1067.     CALL Windows(2, 42, 13, 75, 1, 0, 3, wattr3%, "SFX Only")
  1068.     CALL SaveScrn(ScrnArry(6001))
  1069.     IF crt <> 2 THEN
  1070.         CALL MilliDelay(250)
  1071.     END IF
  1072.  
  1073.  
  1074.     CALL Windows(5, 52, 23, 75, 0, 1, 0, wattr4%, "Grow Only")
  1075.     CALL SaveScrn(ScrnArry(8001))
  1076.     IF crt <> 2 THEN
  1077.         CALL MilliDelay(250)
  1078.     END IF
  1079.  
  1080.  
  1081.     CALL Windows(15, 32, 24, 52, 1, 1, 2, wattr5%, "Slo-Gro & SFX")
  1082.     CALL SaveScrn(ScrnArry(10001))
  1083.     IF crt <> 2 THEN
  1084.         CALL MilliDelay(250)
  1085.     END IF
  1086.  
  1087.  
  1088.     CALL Windows(2, 2, 6, 22, 1, 0, 3, wattr6%, "SFX Only")
  1089.     CALL SaveScrn(ScrnArry(12001))
  1090.     CALL MilliDelay(250)
  1091.  
  1092.  
  1093.     COLOR fgh, 1
  1094.     LOCATE 13, 6
  1095.     PRINT " With Save / RestScrn "
  1096.     LOCATE , 6
  1097.     PRINT "we can back up one "
  1098.     LOCATE , 6
  1099.     PRINT "layer at a time..."
  1100.     LOCATE , 6
  1101.     PRINT "I have added a .5 sec"
  1102.     LOCATE , 6
  1103.     PRINT "delay so you see what"
  1104.     LOCATE , 6
  1105.     PRINT "is going on."
  1106.  
  1107.     CALL ClrKBd                         ' eat up type ahead
  1108.     GOSUB ContPrompt
  1109.  
  1110.    
  1111.     CALL RestScrn(ScrnArry(10001))      ' pop back windows 1 at a time
  1112.     CALL MilliDelay(500)
  1113.  
  1114.     CALL RestScrn(ScrnArry(8001))
  1115.     CALL MilliDelay(500)
  1116.  
  1117.     CALL RestScrn(ScrnArry(6001))
  1118.     CALL MilliDelay(500)
  1119.  
  1120.     CALL RestScrn(ScrnArry(4001))
  1121.     CALL MilliDelay(500)
  1122.  
  1123.     CALL RestScrn(ScrnArry(2001))
  1124.     CALL MilliDelay(500)
  1125.  
  1126.     CALL RestScrn(ScrnArry(1))          ' original screen
  1127.  
  1128.     COLOR 15, 1
  1129.     CALL Windows(12, 5, 23, 30, 0, 0, 2, wattr2%, "Window 2")
  1130.     LOCATE 13, 6
  1131.     PRINT "We still have each level"
  1132.     LOCATE , 6
  1133.     PRINT "of screen in memory, and"
  1134.     LOCATE , 6
  1135.     PRINT "can recall any level we"
  1136.     LOCATE , 6
  1137.     PRINT "choose! "
  1138.     LOCATE , 6
  1139.     PRINT "Let's peel them back "
  1140.     LOCATE , 6
  1141.     PRINT "with sound."
  1142.  
  1143.     GOSUB ContPrompt
  1144.  
  1145.                                         ' compare this method with above
  1146.     FOR x = 10001 TO 1 STEP -2000
  1147.         CALL RestScrn(ScrnArry(x))
  1148.         CALL Chirp(0)
  1149.         CALL MilliDelay(500)
  1150.     NEXT x
  1151.  
  1152. RETURN
  1153.  
  1154.  
  1155. VidDemo:
  1156.    CALL vidoff
  1157.    ky$ = " "
  1158.    vdone = 0                              ' set loop indicator
  1159.    cy = 0
  1160.  
  1161.    DO UNTIL vdone
  1162.        CALL MilliDelay(1500)                ' delay 1.5 secs
  1163.  
  1164.        IF KeyReady THEN                     ' is a key waiting?
  1165.            CALL vidon
  1166.            CALL SaveScrn(ScrnArry(1))
  1167.  
  1168.            msg$ = "Diable video again? "
  1169.            prompt$ = "Yes or No"
  1170.            ok$ = "YN"
  1171.            ret$ = " "
  1172.            ret$ = DialogBox$(msg$, prompt$, ok$)
  1173.            CALL RestScrn(ScrnArry(1))
  1174.  
  1175.            IF ret$ = "N" THEN
  1176.                vdone = 1
  1177.            ELSE
  1178.                CALL vidoff
  1179.            END IF
  1180.        END IF
  1181.  
  1182.        IF cy MOD 2 = 0 THEN
  1183.            PLAY "L64O3AGE"              ' I'm bored
  1184.        ELSE
  1185.            SOUND 1200, .5               ' make some noise
  1186.        END IF
  1187.        cy = cy + 1
  1188.  
  1189.    LOOP
  1190. RETURN
  1191.  
  1192.  
  1193. MiscDemo:                               ' forgot what I was going to put here
  1194. RETURN
  1195.  
  1196.  
  1197. ' **************** demo program support functions  **************
  1198. LoadScrn:
  1199.     ScrF = FREEFILE                     ' get BAS File No
  1200.     OPEN ScrFil$ FOR INPUT AS #ScrF
  1201.     scrFHandle = FILEATTR(ScrF, 2)      ' convert to handle
  1202.  
  1203.     bytes = 4000                        ' 4000 bytes per screen
  1204.     seekPos& = CLNG(CLNG(ScrNum - 1) * 4000) + 1
  1205.     SEEK #ScrF, seekPos&                ' use QB to seek to right spot
  1206.     errc = FReadArray(ScrText(ScrPOS), scrFHandle, bytes)
  1207.     CLOSE #ScrF                         ' no reason to keep file open
  1208. RETURN
  1209.  
  1210.  
  1211. HowToRunDemo:
  1212.     CLS
  1213.     LOCATE 5, 5
  1214.     PRINT "Cannot find 'SCRLIB17.DAT'"
  1215.     PRINT TAB(5); "This demo depends on an external set of screens that holds"
  1216.     PRINT TAB(5); "the various screen displays.  Restart the demo from the"
  1217.     PRINT TAB(5); "batch file provided or using the command line listed in the demo source."
  1218. RETURN
  1219.  
  1220. ContPrompt:
  1221.     SOUND 1200, .5
  1222.     CALL ClrKBd
  1223.     CALL TimeSquare(TSqMsg$(), 24, 25, NAttr, 0)
  1224.     CALL ClrKBd                    ' some people get impatient
  1225.     IF DoFade THEN
  1226.         CALL Fade
  1227.     END IF
  1228. RETURN
  1229.  
  1230.  
  1231.